home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / faq-s.zip / VOTING.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-13  |  14KB  |  494 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit voting;
  5.  
  6. interface
  7.  
  8. uses gentypes,configrt,gensubs,subs1,subs2,userret,overret1,modem;
  9.  
  10. procedure votingbooth (getmandatory:boolean);
  11.  
  12. implementation
  13.  
  14. procedure votingbooth (getmandatory:boolean);
  15. var curtopic:topicrec;
  16.     curtopicnum:integer;
  17.  
  18.   function votefn (n:integer):sstr;
  19.   begin
  20.     votefn:=bbsdatadir+'VoteFile.'+strr(n)
  21.   end;
  22.  
  23.   procedure opentopicdir;
  24.   var n:integer;
  25.   begin
  26.     assign (tofile,bbsdatadir+'VOTEDIR.dat');
  27.     reset (tofile);
  28.     if ioresult<>0 then begin
  29.       close (tofile);
  30.       n:=ioresult;
  31.       rewrite (tofile)
  32.     end
  33.   end;
  34.  
  35.   function numtopics:integer;
  36.   begin
  37.     numtopics:=filesize (tofile)
  38.   end;
  39.  
  40.   procedure opentopic (n:integer);
  41.   var q:integer;
  42.   begin
  43.     curtopicnum:=n;
  44.     close (chfile);
  45.     assign (chfile,votefn(n));
  46.     reset (chfile);
  47.     if ioresult<>0 then begin
  48.       close (chfile);
  49.       q:=ioresult;
  50.       rewrite (chfile)
  51.     end;
  52.     seek (tofile,n-1);
  53.     read (tofile,curtopic)
  54.   end;
  55.  
  56.   function numchoices:integer;
  57.   begin
  58.     numchoices:=filesize (chfile)
  59.   end;
  60.  
  61.   procedure writecurtopic;
  62.   begin
  63.     seek (tofile,curtopicnum-1);
  64.     write (tofile,curtopic)
  65.   end;
  66.  
  67.   procedure listchoices;
  68.   var ch:choicerec;
  69.       cnt:integer;
  70.   begin
  71.     writehdr ('Your Choices');
  72.     seek (chfile,0);
  73.     for cnt:=1 to numchoices do
  74.       begin
  75.         read (chfile,ch);
  76.         writeln (cnt:2,'.  ',ch.choice);
  77.         if break then exit
  78.       end
  79.   end;
  80.  
  81.   function addchoice:integer;
  82.   var ch:choicerec;
  83.   begin
  84.     addchoice:=0;
  85.     buflen:=70;
  86.     writestr (^M'Enter new choice: &');
  87.     if length(input)<2 then exit;
  88.     addchoice:=numchoices+1;
  89.     ch.numvoted:=0;
  90.     ch.choice:=input;
  91.     seek (chfile,numchoices);
  92.     write (chfile,ch);
  93.     writelog (20,2,ch.choice)
  94.   end;
  95.  
  96.   procedure getvote (mandatory:boolean);
  97.   var cnt,chn:integer;
  98.       k:char;
  99.       ch:choicerec;
  100.       tmp:lstr;
  101.       besh,a:boolean;
  102.   begin
  103.     if urec.voted[curtopicnum]<>0 then begin
  104.       writeln ('Sorry, can''t vote twice!!');
  105.       exit
  106.     end;
  107.     a:=ulvl>=curtopic.addlevel;
  108.     tmp:=+^P'Select '^R'['^S'?/List';
  109.     if a then tmp:=tmp+', [A]dd';
  110.     tmp:=tmp+^R']'^P':';
  111.     listchoices;
  112.     repeat
  113.       besh:=false;
  114.       input:=chr(0);
  115.       input:='';
  116.       writestr (tmp);
  117.       chn:=valu(input);
  118.       if chn<1 then begin
  119.         k:=upcase(input[1]);
  120.         if k='?'
  121.           then listchoices
  122.           else if k='A'
  123.             then if a
  124.               then begin
  125.                   besh:=true;
  126.                   chn:=addchoice
  127.               end else writestr ('You may not add choices to this topic!')
  128.     end;
  129.     until (chn>0) or (besh=true);
  130.     if (chn>numchoices) or (chn<0) then begin
  131.       writeln ('Choice # out of range!');
  132.       exit
  133.     end;
  134.     curtopic.numvoted:=curtopic.numvoted+1;
  135.     writecurtopic;
  136.     seek (chfile,chn-1);
  137.     read (chfile,ch);
  138.     ch.numvoted:=ch.numvoted+1;
  139.     seek (chfile,chn-1);
  140.     write (chfile,ch);
  141.     urec.voted[curtopicnum]:=chn;
  142.     writeurec;
  143.     writeln ('Thanks for voting!')
  144.   end;
  145.  
  146.   procedure showresults;
  147.   var cnt,tpos,n:integer;
  148.       ch:choicerec;
  149.       percent:real;
  150.   begin
  151.     if urec.voted[curtopicnum]=0 then begin
  152.       writeln ('Sorry, You must vote First!!');
  153.       exit
  154.     end;
  155.     seek (chfile,0);
  156.     tpos:=1;
  157.     for cnt:=1 to filesize (chfile) do begin
  158.       read (chfile,ch);
  159.       n:=length(ch.choice)+2;
  160.       if n>tpos then tpos:=n
  161.     end;
  162.     writehdr ('The results so far');
  163.     seek (chfile,0);
  164.     for cnt:=1 to numchoices do if not break then begin
  165.       read (chfile,ch);
  166.       tab (ch.choice,tpos);
  167.       writeln (ch.numvoted)
  168.     end;
  169.     if numusers>0
  170.       then percent:=100.0*curtopic.numvoted/numusers
  171.       else percent:=0;
  172.     writeln (^M,percent:0:0,'% of ',numusers,' have voted.')
  173.   end;
  174.  
  175.   procedure listtopics;
  176.   var t:topicrec;
  177.       cnt:integer;
  178.   begin
  179.     writehdr ('Voting Topics');
  180.     seek (tofile,0);
  181.     for cnt:=1 to numtopics do
  182.       if not break then begin
  183.         read (tofile,t);
  184.         writeln (cnt:2,'.  ',t.topicname)
  185.       end
  186.   end;
  187.  
  188.   procedure addtopic;
  189.   var t:topicrec;
  190.       ch:choicerec;
  191.       u:userrec;
  192.       cnt,tpn:integer;
  193.   begin
  194.     if numtopics>=maxtopics then
  195.       begin
  196.         writeln ('No more room to add a topic!');
  197.         exit
  198.       end;
  199.     tpn:=numtopics+1;
  200.     writestr ('Topic name:');
  201.     if length(input)=0 then exit;
  202.     t.topicname:=input;
  203.     t.numvoted:=0;
  204.     writeurec;
  205.     for cnt:=1 to numusers do begin
  206.       seek (ufile,cnt);
  207.       read (ufile,u);
  208.       if u.voted[tpn]<>0
  209.         then
  210.           begin
  211.             u.voted[tpn]:=0;
  212.             seek (ufile,cnt);
  213.             write (ufile,u)
  214.           end
  215.     end;
  216.     readurec;
  217.     writestr ('[Force Topic for Voting]: *');
  218.     t.mandatory:=yes;
  219.     writestr ('[Adding Own Choices Available]:[CR/No]: *');
  220.     if yes then begin
  221.       writestr ('[Min. Level to Add Choices]: *');
  222.       t.addlevel:=valu(input)
  223.     end else t.addlevel:=maxint;
  224.     seek (tofile,tpn-1);
  225.     write (tofile,t);
  226.     opentopic (tpn);
  227.     writeln (^M^B'Enter choices, blank line to end.');
  228.     cnt:=1;
  229.     repeat
  230.       buflen:=70;
  231.       writestr (^R'Choice number '^P+strr(cnt)+^R': &');
  232.       if length(input)>0 then begin
  233.         cnt:=cnt+1;
  234.         ch.numvoted:=0;
  235.         ch.choice:=input;
  236.         write (chfile,ch)
  237.       end
  238.     until (length(input)=0) or hungupon;
  239.     writeln ('Topic created!');
  240.     writelog (20,3,strr(tpn)+' ('+t.topicname+')')
  241.   end;
  242.  
  243.   procedure maybeaddtopic;
  244.   begin
  245.     writestr ('Create new topic? *');
  246.     if yes then addtopic
  247.   end;
  248.  
  249.   procedure selecttopic;
  250.   var ch:integer;
  251.   begin
  252.     input:=copy(input,2,255);
  253.     if input='' then input:=' ';
  254.     repeat
  255.       if length(input)=0 then exit;
  256.       ch:=valu(input);
  257.       if ch>numtopics then begin
  258.         ch:=numtopics+1;
  259.         if issysop then maybeaddtopic;
  260.         if numtopics<>ch then exit
  261.       end;
  262.       if (ch<1) or (ch>numtopics) then begin
  263.         if input='?' then listtopics;
  264.         writestr ('Topic # [?/List]:');
  265.         ch:=0
  266.       end
  267.     until (ch>0) or hungupon;
  268.     opentopic (ch)
  269.   end;
  270.  
  271.   procedure deltopic;
  272.   var un,cnt:integer;
  273.       u:userrec;
  274.       f:file;
  275.       t:topicrec;
  276.       tn:lstr;
  277.   begin
  278.     tn:=tn+^R+' Topic '^S+strr(curtopicnum)+^R' ('+curtopic.topicname+')';
  279.     writestr ('Delete topic '+tn+'? *');
  280.     if not yes then exit;
  281.     writelog (20,1,tn);
  282.     close (chfile);
  283.     erase (chfile);
  284.     cnt:=ioresult;
  285.     for cnt:=curtopicnum to numtopics-1 do begin
  286.       assign (f,votefn(cnt+1));
  287.       rename (f,votefn(cnt));
  288.       un:=ioresult;
  289.       seek (tofile,cnt);
  290.       read (tofile,t);
  291.       seek (tofile,cnt-1);
  292.       write (tofile,t)
  293.     end;
  294.     seek (tofile,numtopics-1);
  295.     truncate (tofile);
  296.     if curtopicnum<numtopics then begin
  297.       writeln ('Adjusting user voting record...');
  298.       writeurec;
  299.       for un:=1 to numusers do begin
  300.         seek (ufile,un);
  301.         read (ufile,u);
  302.         for cnt:=curtopicnum to numtopics do
  303.           u.voted[cnt]:=u.voted[cnt+1];
  304.         seek (ufile,un);
  305.         write (ufile,u)
  306.       end;
  307.       readurec
  308.     end;
  309.     if numtopics>0 then opentopic (1)
  310.   end;
  311.  
  312.   procedure removechoice;
  313.   var n:integer;
  314.       delled,c:choicerec;
  315.       cnt:integer;
  316.       u:userrec;
  317.   begin
  318.     n:=valu(copy(input,2,255));
  319.     if (n<1) or (n>numchoices) then n:=0;
  320.     while n=0 do begin
  321.       writestr (^M'Choice to delete ['^U'?/List'^P']:');
  322.       n:=valu(input);
  323.       if n=0
  324.         then if input='?'
  325.           then listchoices
  326.           else exit
  327.     end;
  328.     if (n<1) or (n>numchoices) then exit;
  329.     seek (chfile,n-1);
  330.     read (chfile,delled);
  331.     for cnt:=n to numchoices-1 do begin
  332.       seek (chfile,cnt);
  333.       read (chfile,c);
  334.       seek (chfile,cnt-1);
  335.       write (chfile,c)
  336.     end;
  337.     seek (chfile,numchoices-1);
  338.     truncate (chfile);
  339.     curtopic.numvoted:=curtopic.numvoted-delled.numvoted;
  340.     writecurtopic;
  341.     write (^B^M'Choice deleted; updating user voting records...');
  342.     writeurec;
  343.     for cnt:=1 to numusers do begin
  344.       seek (ufile,cnt);
  345.       read (ufile,u);
  346.       u.voted[curtopicnum]:=0;
  347.       seek (ufile,cnt);
  348.       write (ufile,u)
  349.     end;
  350.     readurec;
  351.     writeln (^G^B'Done.')
  352.   end;
  353.  
  354.   procedure nexttopic;
  355.   begin
  356.     if curtopicnum=numtopics
  357.       then writeln ('No more topics!')
  358.       else opentopic (curtopicnum+1)
  359.   end;
  360.  
  361.   procedure voteonmandatory;
  362.   var n:integer;
  363.       t:topicrec;
  364.   begin
  365.     for n:=1 to numtopics do
  366.       if urec.voted[n]=0 then begin
  367.         seek (tofile,n-1);
  368.         read (tofile,t);
  369.         if t.mandatory then begin
  370.           opentopic (n);
  371.           clearbreak;
  372.           nobreak:=true;
  373.           writeln (^M'Mandatory voting topic: ['^S,t.topicname,^R']'^M);
  374.        {  listchoices;  }
  375.           getvote (true);
  376.           if urec.voted[curtopicnum]<>0 then begin
  377.             buflen:=1;
  378.             writestr (^M'See results? [CR/No]: *');
  379.             if yes then showresults
  380.           end
  381.         end
  382.       end
  383.   end;
  384.  
  385.   procedure sysopvoting;
  386.   var q,dum:integer;
  387.       firm:mstr;
  388.   begin
  389.     writelog (19,1,curtopic.topicname);
  390.     repeat
  391.       q:=menu ('Sysop Voting','VSYSOP','QACDR?');
  392.       if hungupon then exit;
  393.       case q of
  394.         2:addtopic;
  395.         3:dum:=addchoice;
  396.         4:deltopic;
  397.         5:removechoice;
  398.         6:begin
  399. writeln ('C╔═════════════════════════════════════╗Hs');
  400. writeln ('uC║ Voting Sysop Section                ║Hs');
  401. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  402. writeln ('u═════════════════════════════════╗HC║ [A]  s');
  403. writeln ('uAdd Topic                      ║HC║ [Cs');
  404. writeln ('u]  Add Choice                     ║HC║ [s');
  405. writeln ('uD]  Delete Topic                   ║Hs');
  406. writeln ('uC║ [Q]  Quit                           s');
  407. writeln ('u║HC║ [R]  Delete Choice           s');
  408. writeln ('u       ║HC║ [?]  View This Menu   s');
  409. writeln ('u              ║HC╚═══════════════════════════════A');
  410. writeln ('C══════╝');
  411. writeln;
  412. pause;
  413.            end;
  414.       end
  415.     until (q=1) or hungupon or (numtopics=0)
  416.   end;
  417.  
  418. var q:integer;
  419. label exit;
  420. begin
  421.   cursection:=votingsysop;
  422.   opentopicdir;
  423.   repeat
  424.     if numtopics=0 then begin
  425.       if getmandatory then goto exit;
  426.       writeln ('No Voting Booths right now!');
  427.       if not issysop
  428.         then goto exit
  429.         else
  430.           begin
  431.             writestr ('Make NEW Voting topic #1? *');
  432.             if yes
  433.               then addtopic
  434.               else goto exit
  435.           end
  436.     end
  437.   until (numtopics>0) or hungupon;
  438.   if hungupon then goto exit;
  439.   if getmandatory then begin
  440.     voteonmandatory;
  441.     goto exit
  442.   end;
  443.   opentopic (1);
  444.   writehdr ('The Voting Booths');
  445.   writeln ('Number of topics: ',numtopics);
  446.   repeat
  447.     writeln (^M'Active topic: ['^S,curtopicnum,^R'] ['^S,curtopic.topicname,^R']');
  448.     q:=menu ('Voting','VOTING','QS_VLR#*%@');
  449.     if hungupon then goto exit;
  450.     if q<0
  451.       then
  452.         begin
  453.           q:=-q;
  454.           if q<=numtopics then opentopic (q);
  455.           q:=0
  456.         end
  457.       else
  458.         case q of
  459.           2,8:selecttopic;
  460.           3:nexttopic;
  461.           4:getvote (false);
  462.           5:listchoices;
  463.           6:showresults;
  464.           9:sysopvoting;
  465.          10:begin
  466. writeln ('C╔═════════════════════════════════════╗Hs');
  467. writeln ('uC║ Voting Section                      ║Hs');
  468. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  469. writeln ('u═════════════════════════════════╗HC║ [L]  s');
  470. writeln ('uList Choices                   ║HC║ [Qs');
  471. writeln ('u]  Quit                           ║HC║ [s');
  472. writeln ('uR]  Results                        ║Hs');
  473. writeln ('uC║ [S]  Select Topic                   s');
  474. writeln ('u║HC║ [V]  Vote on Topic           s');
  475. writeln ('u       ║HC║ [%]  Voting Sysop Sects');
  476. writeln ('uion           ║HC║ [#]  Open Topics');
  477. writeln ('u #                   ║HC║ [*]  Sels');
  478. writeln ('uect Topic                   ║HC║ [CR] s');
  479. writeln ('uNext Topic                     ║HC║ [?s');
  480. writeln ('u]  View This Menu                 ║HC╚═A');
  481. writeln ('C════════════════════════════════════╝');
  482. writeln;
  483. pause;
  484.            end;
  485.         end
  486.   until (q=1) or hungupon or (numtopics=0);
  487.   if numtopics=0 then writeln (^B'No voting topics right now!');
  488.   exit:
  489.   close (tofile);
  490.   close (chfile)
  491. end;
  492.  
  493. begin
  494. end.